home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
kcl.lha
/
cmpnew
/
cmpbind.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1987-06-03
|
3KB
|
93 lines
;;; CMPBIND Variable Binding.
;;;
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
(in-package 'compiler)
(si:putprop 'bds-bind 'set-bds-bind 'set-loc)
;;; Those functions that call the following binding functions should
;;; rebind the special variables,
;;; *vs*, *clink*, *ccb-vs*, and *unwind-exit*.
(defun c2bind (var)
(case (var-kind var)
(LEXICAL
(when (var-ref-ccb var)
(wt-nl)
(wt-vs (var-ref var))
(wt "=MMcons(") (wt-vs (var-ref var))
(wt ",") (wt-clink) (wt ");")
(clink (var-ref var))
(setf (var-ref-ccb var) (ccb-vs-push))))
(SPECIAL
(wt-nl "bds_bind(VV[" (var-loc var) "],") (wt-vs (var-ref var))
(wt ");")
(push 'bds-bind *unwind-exit*))
(t
(wt-nl "V" (var-loc var) "=")
(case (var-kind var)
(OBJECT)
(FIXNUM (wt "fix"))
(CHARACTER (wt "char_code"))
(LONG-FLOAT (wt "lf"))
(SHORT-FLOAT (wt "sf"))
(t (baboon)))
(wt "(") (wt-vs (var-ref var)) (wt ");")))
)
(defun c2bind-loc (var loc)
(case (var-kind var)
(LEXICAL
(cond ((var-ref-ccb var)
(wt-nl)
(wt-vs (var-ref var))
(wt "=MMcons(" loc ",") (wt-clink) (wt ");")
(clink (var-ref var))
(setf (var-ref-ccb var) (ccb-vs-push)))
(t
(wt-nl) (wt-vs (var-ref var)) (wt "= " loc ";"))))
(SPECIAL
(wt-nl "bds_bind(VV[" (var-loc var) "]," loc ");")
(push 'bds-bind *unwind-exit*))
(t
(wt-nl "V" (var-loc var) "= ")
(case (var-kind var)
(OBJECT (wt-loc loc))
(FIXNUM (wt-fixnum-loc loc))
(CHARACTER (wt-character-loc loc))
(LONG-FLOAT (wt-long-float-loc loc))
(SHORT-FLOAT (wt-short-float-loc loc))
(t (baboon)))
(wt ";")))
)
(defun c2bind-init (var init)
(case (var-kind var)
(LEXICAL
(cond ((var-ref-ccb var)
(let ((loc (list 'vs (var-ref var))))
(let ((*value-to-go* loc))
(c2expr* init))
(wt-nl loc "=MMcons(" loc ",") (wt-clink *clink*)
(wt ");"))
(clink (var-ref var))
(setf (var-ref-ccb var) (ccb-vs-push)))
(t
(let ((*value-to-go* (list 'vs (var-ref var))))
(c2expr* init)))))
(SPECIAL
(let ((*value-to-go* (list 'bds-bind (var-loc var))))
(c2expr* init))
(push 'bds-bind *unwind-exit*))
((OBJECT FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT)
(let ((*value-to-go* (list 'var var nil)))
(c2expr* init)))
(t (baboon)))
)
(defun set-bds-bind (loc vv)
(wt-nl "bds_bind(VV[" vv "]," loc ");"))